home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / method.scm < prev    next >
Text File  |  1995-10-13  |  15KB  |  513 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Generic procedure package
  5.  
  6. ; This is written in fairly portable Scheme.  It needs:
  7. ;   Scheme 48 low-level macros (explicit renaming), in one small place.
  8. ;   (CALL-ERROR message proc arg ...)  - signal an error.
  9. ;   Record package and DEFINE-RECORD-TYPES macro.
  10. ;   An object :RECORD-TYPE which is the record type descriptor for
  11. ;     record type descriptors (records are assumed to be records).
  12. ;     This wouldn't be difficult to change.
  13. ;   A RECORD? predicate (not essential - only for defining a DISCLOSE
  14. ;     method for records).
  15.  
  16. ; --------------------
  17. ; Simple types.
  18. ; More specific types have higher priorities.  The priorities are used
  19. ; to establish the ordinary in which type predicates are called.
  20.  
  21. (define-record-type simple-type :simple-type
  22.   (really-make-simple-type supers predicate priority id)
  23.   simple-type?
  24.   (supers simple-type-superiors)
  25.   (predicate simple-type-predicate)
  26.   (priority simple-type-priority)
  27.   (id simple-type-id)
  28.   (more))    ;if needed later
  29.  
  30. (define-record-discloser :simple-type
  31.   (lambda (c) `(simple-type ,(simple-type-id c))))
  32.  
  33. (define (make-simple-type supers predicate id)
  34.   (make-immutable!
  35.    (really-make-simple-type supers
  36.                 predicate
  37.                 (compute-priority supers)
  38.                 id)))
  39.  
  40. (define (compute-priority supers)
  41.   (if (null? supers)
  42.       0
  43.       (+ (apply max (map %type-priority supers))
  44.      *increment*)))
  45.  
  46. (define *increment* 10)
  47.  
  48.  
  49. ; These two procedures will become generic later, but must exist early
  50. ; in order to be able to bootstrap the method definition mechanism.
  51.  
  52. (define (%type-priority type)
  53.   (cond ((simple-type? type)
  54.      (simple-type-priority type))
  55.     ((record-type? type)
  56.      (record-type-priority type))
  57.     (else (type-priority type))))    ;generic
  58.  
  59. (define (%type-predicate type)
  60.   (cond ((simple-type? type)
  61.      (simple-type-predicate type))
  62.     ((record-type? type)
  63.      (record-predicate type))
  64.     (else (type-predicate type))))  ;generic
  65.  
  66. (define (%same-type? t1 t2)
  67.   (or (eq? t1 t2)
  68.       (if (simple-type? t1)
  69.       #f
  70.       (if (record-type? t1)
  71.           #f
  72.           (same-type? t1 t2)))))
  73.       
  74.  
  75. (define-syntax define-simple-type
  76.   (syntax-rules ()
  77.     ((define-simple-type ?name (?super ...) ?pred)
  78.      (define ?name (make-simple-type (list ?super ...) ?pred '?name)))))
  79.  
  80. ; --------------------
  81. ; Built-in Scheme types
  82.  
  83. (define-simple-type :syntax    () #f)
  84. (define-simple-type :values    () #f)    ;any number of values
  85.  
  86. (define (value? x) #t)
  87. (define-simple-type :value     (:values) value?)
  88. (define-simple-type :zero      (:values) (lambda (x) #f))
  89.  
  90. (define-simple-type :number    (:value) number?)
  91. (define-simple-type :complex   (:number) complex?)
  92. (define-simple-type :real      (:complex) real?)
  93. (define-simple-type :rational  (:real) rational?)
  94. (define-simple-type :integer   (:rational) integer?)
  95. (define-simple-type :exact-integer (:integer)
  96.   (lambda (n) (and (integer? n) (exact? n))))
  97.  
  98. (define-simple-type :boolean   (:value) boolean?)
  99. (define-simple-type :symbol    (:value) symbol?)
  100. (define-simple-type :char      (:value) char?)
  101. (define-simple-type :null      (:value) null?)
  102. (define-simple-type :pair      (:value) pair?)
  103. (define-simple-type :vector    (:value) vector?)
  104. (define-simple-type :string    (:value) string?)
  105. (define-simple-type :procedure (:value) procedure?)
  106.  
  107. (define-simple-type :input-port  (:value) input-port?)
  108. (define-simple-type :output-port (:value) output-port?)
  109. (define-simple-type :eof-object     (:value) eof-object?)
  110.  
  111. ; If there is no RECORD? predicate, do
  112. ;   (define-simple-type :record     (:value) value?)
  113. ; and change the DISCLOSE method for records to
  114. ;   (or (disclose-record obj) (next-method)).
  115.  
  116. (define-simple-type :record     (:value) record?)
  117.  
  118. ; Given a record type, RECORD-TYPE-PRIORITY returns its priority.
  119. ; Here we establish that every record type is a direct subtype of the
  120. ; :RECORD type.
  121.  
  122. (define record-type-priority
  123.   (let ((r-priority
  124.      (simple-type-priority (make-simple-type (list :record) #f #f))))
  125.     (lambda (rt) r-priority)))
  126.  
  127. ; --------------------
  128. ; Method-info records are triples <type-list, n-ary?, proc>.
  129.  
  130. (define-record-type method-info :method-info
  131.   (really-make-method-info types n-ary? proc)
  132.   method-info?
  133.   (types method-info-types)
  134.   (n-ary? method-info-n-ary?)
  135.   (proc method-info-proc))
  136.  
  137. (define (make-method-info types n-ary? proc)
  138.   (make-immutable! (really-make-method-info types n-ary? proc)))
  139.  
  140. (define-record-discloser :method-info
  141.   (lambda (info)
  142.     `(method-info ,(method-info-types info) ,(method-info-n-ary? info))))
  143.  
  144. ; --------------------
  145. ; Method lists
  146.  
  147. ; A method list is a list of method-info records, sorted in order from
  148. ; most specific to least specific.
  149.  
  150. (define (empty-method-list) '())
  151.  
  152. ; insert-method inserts an entry into a method list so that the most
  153. ; specific methods come earliest in the list.  The last method should
  154. ; be a default method or error signal(l)er.
  155.  
  156. (define (insert-method info ms)
  157.   (let recur ((ms ms))
  158.     (if (null? ms)
  159.     (cons info ms)
  160.     (if (more-specific? (car ms) info)
  161.         (cons (car ms) (recur (cdr ms)))
  162.         (cons info
  163.           (if (same-applicability? (car ms) info)
  164.               (cdr ms)
  165.               ms))))))
  166.  
  167. ; Replace an existing method with identical domain.
  168.  
  169. (define (same-applicability? info1 info2)
  170.   (and (every2 %same-type?
  171.            (method-info-types info1)
  172.            (method-info-types info2))
  173.        (eq? (method-info-n-ary? info1) (method-info-n-ary? info2))))
  174.  
  175. (define (every2 pred l1 l2)
  176.   (if (null? l1)
  177.       (null? l2)
  178.       (if (null? l2)
  179.       #f
  180.       (and (pred (car l1) (car l2)) (every2 pred (cdr l1) (cdr l2))))))
  181.  
  182. ; This interacts with methods->perform, below.
  183. ; In this version, it's supposed to be a total order.
  184.  
  185. (define (more-specific? info1 info2)
  186.   (let ((t1 (method-info-types info1))
  187.     (t2 (method-info-types info2)))
  188.     (let ((l1 (length t1))
  189.       (l2 (length t2))
  190.       (foo? (and (not (method-info-n-ary? info1))
  191.              (method-info-n-ary? info2))))
  192.       (if (= l1 l2)
  193.       (or foo?
  194.           (let loop ((l1 t1)
  195.              (l2 t2))
  196.         (if (null? l2)
  197.             #f
  198.             (or (more-specific-type? (car l1) (car l2))
  199.             (and (%same-type? (car l1) (car l2))
  200.                  (loop (cdr l1) (cdr l2)))))))
  201.       (and (> l1 l2)
  202.            foo?)))))
  203.   
  204.  
  205. (define (more-specific-type? t1 t2)
  206.   (> (%type-priority t1) (%type-priority t2)))
  207.  
  208. ; --------------------
  209. ; A method table is a cell that contains a method list.
  210. ; Note that the method table is not reachable from the generic
  211. ; procedure.  This means good things for the GC.
  212.  
  213. (define-record-type method-table :method-table
  214.   (really-make-method-table methods prototype
  215.                 generic get-perform set-perform! id)
  216.   method-table?
  217.   (methods method-table-methods set-method-table-methods!)
  218.   (prototype method-table-prototype)
  219.   (generic make-generic)
  220.   (get-perform method-table-get-perform)
  221.   (set-perform! method-table-set-perform!)
  222.   (id method-table-id))
  223.  
  224. (define-record-discloser :method-table
  225.   (lambda (t) `(method-table ,(method-table-id t))))
  226.  
  227. (define (make-method-table id . option)
  228.   (let* ((prototype (if (null? option)
  229.             (make-method-info '() #t #f)
  230.             (car option)))
  231.      (mtable (call-with-values make-cell-for-generic
  232.            (lambda (generic get-perform set-perform!)
  233.              (really-make-method-table '()
  234.                            prototype
  235.                            generic
  236.                            get-perform
  237.                            set-perform!
  238.                            id)))))
  239.     (set-final-method!
  240.          mtable
  241.      (lambda (next-method . args)
  242.        (apply call-error "invalid or unimplemented operation"
  243.           id args)))
  244.     mtable))
  245.  
  246. (define (make-cell-for-generic)
  247.   (let ((perform #f))
  248.     ;; PERFORM always caches (METHODS->PERFORM method-list prototype).
  249.     (values (lambda args (perform args)) ;Generic proc
  250.         (lambda () perform)
  251.         (lambda (new) (set! perform new)))))
  252.  
  253. (define (add-to-method-table! mtable info)
  254.   (let ((l (insert-method info (method-table-methods mtable))))
  255.     (set-method-table-methods! mtable l)
  256.     ((method-table-set-perform! mtable)
  257.      (methods->perform l (method-table-prototype mtable)))))
  258.  
  259. (define (set-final-method! mtable proc)
  260.   (add-to-method-table! mtable
  261.             (make-method-info '()
  262.                       #t
  263.                       proc)))
  264.  
  265. (define (apply-generic mtable args)
  266.   ;; (apply (make-generic mtable) args)
  267.   (((method-table-get-perform mtable)) args)) ;+++
  268.  
  269. ; DEFINE-GENERIC
  270.  
  271. (define-syntax define-generic
  272.   (syntax-rules ()
  273.     ((define-generic ?name ?mtable-name)
  274.      (begin (define ?mtable-name (make-method-table '?name))
  275.         (define ?name (make-generic ?mtable-name))))
  276.     ((define-generic ?name ?mtable-name (?spec . ?specs))
  277.      (begin (define ?mtable-name
  278.           (make-method-table '?name
  279.                  (method-info ?name ("next" next-method
  280.                                 ?spec . ?specs)
  281.                    (next-method))))
  282.         (define ?name (make-generic ?mtable-name))))))
  283.  
  284. ; --------------------
  285. ; Method combination.
  286.  
  287. ; Here is the specification:
  288.  
  289. ;(define (apply-generic mtable args)
  290. ;  (let loop ((ms (method-table-methods mtable)))
  291. ;    (let ((next-method (lambda () (loop (cdr ms)))))
  292. ;      (if (let test ((ts (method-info-types (car ms)))
  293. ;                     (args args))
  294. ;            (if (null? ts)
  295. ;                (or (null? args)
  296. ;                    (method-info-n-ary? (car ms)))
  297. ;                (and ((%type-predicate (car ts)) (car args))
  298. ;                     (test (cdr ts) (cdr args)))))
  299. ;          (apply (method-info-proc (car ms))
  300. ;                 next-method
  301. ;                 args)
  302. ;          (next-method)))))
  303.  
  304. ;   (perform arg-list)
  305. ;   (apply proc next-method-thunk arg-list)
  306.  
  307. ; This version of METHODS->PERFORM simply marches through all the
  308. ; methods, looking for one that handles the operation.
  309.  
  310. ; The prototype is currently ignored, but it could be put to good use.
  311.  
  312. (define (methods->perform l prototype)
  313.   (let recur ((l l))
  314.     (let* ((info (car l))
  315.        (proc (method-info-proc info)))
  316.       (if (null? (cdr l))
  317.       (last-action proc)
  318.       (one-action (argument-sequence-predicate info)
  319.               proc
  320.               (recur (cdr l)))))))
  321.  
  322. (define (last-action proc)
  323.   (lambda (args)
  324.     (apply proc #f args)))
  325.  
  326. (define (one-action pred proc perform-next)
  327.   (lambda (args)
  328.     (if (pred args)
  329.     (apply proc
  330.            (lambda () (perform-next args))    ; next-method
  331.            args)
  332.     (perform-next args))))
  333.  
  334. (define (argument-sequence-predicate info)
  335.   (let recur ((types (method-info-types info)))
  336.     (if (null? types)
  337.     (if (method-info-n-ary? info) value? null?)
  338.     (let ((pred (%type-predicate (car types)))
  339.           (check-rest (recur (cdr types))))
  340.       (if (eq? pred value?)
  341.           (check-for-next check-rest) ;+++
  342.           (check-next pred check-rest))))))
  343.  
  344. (define (check-for-next check-rest)
  345.   (lambda (args)
  346.     (if (null? args)
  347.     #f
  348.     (check-rest (cdr args)))))
  349.  
  350. (define (check-next pred check-rest)
  351.   (lambda (args)
  352.     (if (null? args)
  353.     #f
  354.     (if (pred (car args))
  355.         (check-rest (cdr args))
  356.         #f))))
  357.  
  358. ; --------------------
  359. ; METHOD-INFO macro.
  360. ; Returns a method-info record.
  361.  
  362. ; You can specify the name of the next-method parameter by saying
  363. ;   (method-info my-name (x y "next" n) body ...)
  364. ; Otherwise, the next-method parameter will be named next-method.
  365. ; Just pretend it's Dylan and that #next reads as "next".
  366.  
  367. (define-syntax method-info
  368.   (syntax-rules ()
  369.     ((method-info ?id ?formals ?body ...)
  370.      (method-internal ?formals () () #f ?id ?body ...))))
  371.  
  372. (define-syntax method-internal
  373.   (syntax-rules ()
  374.     ((method-internal ((?formal1 ?type1) . ?specs)
  375.               (?formal ...) (?type ...) ?next
  376.               . ?rest)
  377.      (method-internal ?specs
  378.               (?formal ... ?formal1) (?type ... ?type1) ?next
  379.               . ?rest))
  380.  
  381.     ((method-internal ("next" ?next . ?specs)
  382.               (?formal ...) (?type ...) ?ignore
  383.               . ?rest)
  384.      (method-internal ?specs
  385.               (?formal ...) (?type ...) ?next
  386.               . ?rest))
  387.  
  388.     ((method-internal (?spec . ?specs)
  389.               (?formal ...) (?type ...) ?next
  390.               . ?rest)
  391.      (method-internal ?specs
  392.               (?formal ... ?spec) (?type ... :value) ?next
  393.               . ?rest))
  394.  
  395.     ((method-internal ?rest
  396.               (?formal ...) (?type ...) ?next
  397.               ?id ?body ...)
  398.      (make-method-info (list ?type ...)
  399.                (not (null? '?rest))
  400.                (let ((?id (with-next-method ?next (?formal ... . ?rest)
  401.                     ?body ...)))
  402.              ;; The (let ...) is a hack for the Scheme 48
  403.              ;; byte code compiler, which will remember
  404.              ;; ?id as the procedure's name.  This should
  405.              ;; aid debugging a little bit since the name
  406.              ;; shows up in backtraces and the inspector.
  407.              ?id)))))
  408.  
  409. ; Non-hygienic, a la Dylan
  410.  
  411. (define-syntax with-next-method
  412.   (cons (lambda (e r c)
  413.       (let ((next (or (cadr e) 'next-method)))
  414.         `(,(r 'lambda) (,next ,@(caddr e))
  415.                ,@(cdddr e))))
  416.     '(lambda)))
  417.  
  418. ; DEFINE-METHOD macro.
  419.  
  420. (define-syntax define-method
  421.   (syntax-rules ()
  422.     ((define-method ?mtable ?formals ?body ...)
  423.      (add-method! ?mtable
  424.           (method-info ?mtable ?formals ?body ...)))))
  425.  
  426. (define-generic add-method! &add-method! (mtable info))
  427.  
  428. (let ((info
  429.        (method-info add-method! ((mtable :method-table) (info :method-info))
  430.      (add-to-method-table! mtable info))))
  431.   (add-to-method-table! &add-method! info))
  432.  
  433. ; --------------------
  434. ; Generic functions on types: sort of a meta-object protocol, huh?
  435.  
  436. (define-generic type-predicate &type-predicate (t))
  437.  
  438. (define-method &type-predicate ((t :record-type)) (record-predicate t))
  439. (define-method &type-predicate ((t :simple-type)) (simple-type-predicate t))
  440.  
  441. (define-generic type-priority &type-priority (t))
  442.  
  443. (define-method &type-priority ((t :record-type)) (record-type-priority t))
  444. (define-method &type-priority ((t :simple-type)) (simple-type-priority t))
  445.  
  446. (define-generic type-superiors &type-superiors (t))
  447.  
  448. (define-method &type-superiors ((t :record-type)) (list :record))
  449. (define-method &type-superiors ((t :simple-type)) (simple-type-superiors t))
  450.  
  451.  
  452. ; Type equivalence
  453.  
  454. (define-generic same-type? &same-type? (t1 t2))
  455.  
  456. (define-method &same-type? (t1 t2) (eq? t1 t2))
  457.  
  458. (define-method &same-type? ((t1 :simple-type) (t2 :simple-type))
  459.   (and (eq? (simple-type-predicate t1) (simple-type-predicate t2))
  460.        (eq? (simple-type-id t1) (simple-type-id t2))))    ;?
  461.  
  462. ; --------------------
  463. ; Singleton types.
  464.  
  465. (define-record-type singleton :singleton
  466.   (singleton value)
  467.   (value singleton-value))
  468.   
  469. (define-record-discloser :singleton
  470.   (lambda (s) `(singleton ,(singleton-value s))))
  471.  
  472. (define (compare-to val)
  473.   (lambda (x) (eqv? x val)))
  474.  
  475. (define-method &type-predicate ((s :singleton))
  476.   (compare-to (singleton-value s)))
  477.  
  478. (define-method &type-priority ((s :singleton)) 1000000)
  479.  
  480. (define-method &same-type? ((s1 :singleton) (s2 :singleton))
  481.   (eqv? (singleton-value s1) (singleton-value s2)))
  482.  
  483. ; --------------------
  484. ; DISCLOSE
  485.  
  486. ; A generic procedure for producing printed representations.
  487. ; Should return one of
  488. ;   - A list (symbol info ...), to be printed as #{Symbol info ...}
  489. ;   - #f, meaning no information available on how to print.
  490. ; This is intended to be used not only by write and display, but also by
  491. ; the pretty printer.
  492.  
  493. (define-generic disclose &disclose (x))
  494.  
  495. (define-method &disclose (obj) #f)
  496.  
  497. (define-method &disclose ((obj :record))
  498.   (or (disclose-record obj)
  499.       '(record)))
  500.  
  501. (define-method &add-method! ((d (singleton &disclose)) info)
  502.   (let ((t (car (method-info-types info))))
  503.     (if (record-type? t)
  504.     (define-record-discloser t (proc->discloser (method-info-proc info)))
  505.     (next-method))))
  506.  
  507. (define (proc->discloser proc)
  508.   (lambda (arg)
  509.     (proc (lambda () #f) arg)))
  510.  
  511. ;(define-method &disclose ((s :singleton))
  512. ;  `(singleton ,(singleton-value s)))
  513.